home *** CD-ROM | disk | FTP | other *** search
/ PC World Komputer 2010 April / PCWorld0410.iso / hity wydania / Ubuntu 9.10 PL / karmelkowy-koliberek-desktop-9.10-i386-PL.iso / casper / filesystem.squashfs / usr / share / tcltk / tk8.4 / comdlg.tcl < prev    next >
Text File  |  2009-04-29  |  8KB  |  304 lines
  1. # comdlg.tcl --
  2. #
  3. #    Some functions needed for the common dialog boxes. Probably need to go
  4. #    in a different file.
  5. #
  6. # RCS: @(#) $Id: comdlg.tcl,v 1.9.2.1 2006/01/25 18:21:41 dgp Exp $
  7. #
  8. # Copyright (c) 1996 Sun Microsystems, Inc.
  9. #
  10. # See the file "license.terms" for information on usage and redistribution
  11. # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  12. #
  13.  
  14. # tclParseConfigSpec --
  15. #
  16. #    Parses a list of "-option value" pairs. If all options and
  17. #    values are legal, the values are stored in
  18. #    $data($option). Otherwise an error message is returned. When
  19. #    an error happens, the data() array may have been partially
  20. #    modified, but all the modified members of the data(0 array are
  21. #    guaranteed to have valid values. This is different than
  22. #    Tk_ConfigureWidget() which does not modify the value of a
  23. #    widget record if any error occurs.
  24. #
  25. # Arguments:
  26. #
  27. # w = widget record to modify. Must be the pathname of a widget.
  28. #
  29. # specs = {
  30. #    {-commandlineswitch resourceName ResourceClass defaultValue verifier}
  31. #    {....}
  32. # }
  33. #
  34. # flags = currently unused.
  35. #
  36. # argList = The list of  "-option value" pairs.
  37. #
  38. proc tclParseConfigSpec {w specs flags argList} {
  39.     upvar #0 $w data
  40.  
  41.     # 1: Put the specs in associative arrays for faster access
  42.     #
  43.     foreach spec $specs {
  44.     if {[llength $spec] < 4} {
  45.         error "\"spec\" should contain 5 or 4 elements"
  46.     }
  47.     set cmdsw [lindex $spec 0]
  48.     set cmd($cmdsw) ""
  49.     set rname($cmdsw)   [lindex $spec 1]
  50.     set rclass($cmdsw)  [lindex $spec 2]
  51.     set def($cmdsw)     [lindex $spec 3]
  52.     set verproc($cmdsw) [lindex $spec 4]
  53.     }
  54.  
  55.     if {[llength $argList] & 1} {
  56.     set cmdsw [lindex $argList end]
  57.     if {![info exists cmd($cmdsw)]} {
  58.         error "bad option \"$cmdsw\": must be [tclListValidFlags cmd]"
  59.     }
  60.     error "value for \"$cmdsw\" missing"
  61.     }
  62.  
  63.     # 2: set the default values
  64.     #
  65.     foreach cmdsw [array names cmd] {
  66.     set data($cmdsw) $def($cmdsw)
  67.     }
  68.  
  69.     # 3: parse the argument list
  70.     #
  71.     foreach {cmdsw value} $argList {
  72.     if {![info exists cmd($cmdsw)]} {
  73.         error "bad option \"$cmdsw\": must be [tclListValidFlags cmd]"
  74.     }
  75.     set data($cmdsw) $value
  76.     }
  77.  
  78.     # Done!
  79. }
  80.  
  81. proc tclListValidFlags {v} {
  82.     upvar $v cmd
  83.  
  84.     set len [llength [array names cmd]]
  85.     set i 1
  86.     set separator ""
  87.     set errormsg ""
  88.     foreach cmdsw [lsort [array names cmd]] {
  89.     append errormsg "$separator$cmdsw"
  90.     incr i
  91.     if {$i == $len} {
  92.         set separator ", or "
  93.     } else {
  94.         set separator ", "
  95.     }
  96.     }
  97.     return $errormsg
  98. }
  99.  
  100. #----------------------------------------------------------------------
  101. #
  102. #            Focus Group
  103. #
  104. # Focus groups are used to handle the user's focusing actions inside a
  105. # toplevel.
  106. #
  107. # One example of using focus groups is: when the user focuses on an
  108. # entry, the text in the entry is highlighted and the cursor is put to
  109. # the end of the text. When the user changes focus to another widget,
  110. # the text in the previously focused entry is validated.
  111. #
  112. #----------------------------------------------------------------------
  113.  
  114.  
  115. # ::tk::FocusGroup_Create --
  116. #
  117. #    Create a focus group. All the widgets in a focus group must be
  118. #    within the same focus toplevel. Each toplevel can have only
  119. #    one focus group, which is identified by the name of the
  120. #    toplevel widget.
  121. #
  122. proc ::tk::FocusGroup_Create {t} {
  123.     variable ::tk::Priv
  124.     if {[winfo toplevel $t] ne $t} {
  125.     error "$t is not a toplevel window"
  126.     }
  127.     if {![info exists Priv(fg,$t)]} {
  128.     set Priv(fg,$t) 1
  129.     set Priv(focus,$t) ""
  130.     bind $t <FocusIn>  [list tk::FocusGroup_In  $t %W %d]
  131.     bind $t <FocusOut> [list tk::FocusGroup_Out $t %W %d]
  132.     bind $t <Destroy>  [list tk::FocusGroup_Destroy $t %W]
  133.     }
  134. }
  135.  
  136. # ::tk::FocusGroup_BindIn --
  137. #
  138. # Add a widget into the "FocusIn" list of the focus group. The $cmd will be
  139. # called when the widget is focused on by the user.
  140. #
  141. proc ::tk::FocusGroup_BindIn {t w cmd} {
  142.     variable FocusIn
  143.     variable ::tk::Priv
  144.     if {![info exists Priv(fg,$t)]} {
  145.     error "focus group \"$t\" doesn't exist"
  146.     }
  147.     set FocusIn($t,$w) $cmd
  148. }
  149.  
  150.  
  151. # ::tk::FocusGroup_BindOut --
  152. #
  153. #    Add a widget into the "FocusOut" list of the focus group. The
  154. #    $cmd will be called when the widget loses the focus (User
  155. #    types Tab or click on another widget).
  156. #
  157. proc ::tk::FocusGroup_BindOut {t w cmd} {
  158.     variable FocusOut
  159.     variable ::tk::Priv
  160.     if {![info exists Priv(fg,$t)]} {
  161.     error "focus group \"$t\" doesn't exist"
  162.     }
  163.     set FocusOut($t,$w) $cmd
  164. }
  165.  
  166. # ::tk::FocusGroup_Destroy --
  167. #
  168. #    Cleans up when members of the focus group is deleted, or when the
  169. #    toplevel itself gets deleted.
  170. #
  171. proc ::tk::FocusGroup_Destroy {t w} {
  172.     variable FocusIn
  173.     variable FocusOut
  174.     variable ::tk::Priv
  175.  
  176.     if {$t eq $w} {
  177.     unset Priv(fg,$t)
  178.     unset Priv(focus,$t) 
  179.  
  180.     foreach name [array names FocusIn $t,*] {
  181.         unset FocusIn($name)
  182.     }
  183.     foreach name [array names FocusOut $t,*] {
  184.         unset FocusOut($name)
  185.     }
  186.     } else {
  187.     if {[info exists Priv(focus,$t)] && $Priv(focus,$t) eq $w} {
  188.         set Priv(focus,$t) ""
  189.     }
  190.     unset -nocomplain FocusIn($t,$w) FocusOut($t,$w)
  191.     }
  192. }
  193.  
  194. # ::tk::FocusGroup_In --
  195. #
  196. #    Handles the <FocusIn> event. Calls the FocusIn command for the newly
  197. #    focused widget in the focus group.
  198. #
  199. proc ::tk::FocusGroup_In {t w detail} {
  200.     variable FocusIn
  201.     variable ::tk::Priv
  202.  
  203.     if {$detail ne "NotifyNonlinear" && $detail ne "NotifyNonlinearVirtual"} {
  204.     # This is caused by mouse moving out&in of the window *or*
  205.     # ordinary keypresses some window managers (ie: CDE [Bug: 2960]).
  206.     return
  207.     }
  208.     if {![info exists FocusIn($t,$w)]} {
  209.     set FocusIn($t,$w) ""
  210.     return
  211.     }
  212.     if {![info exists Priv(focus,$t)]} {
  213.     return
  214.     }
  215.     if {$Priv(focus,$t) eq $w} {
  216.     # This is already in focus
  217.     #
  218.     return
  219.     } else {
  220.     set Priv(focus,$t) $w
  221.     eval $FocusIn($t,$w)
  222.     }
  223. }
  224.  
  225. # ::tk::FocusGroup_Out --
  226. #
  227. #    Handles the <FocusOut> event. Checks if this is really a lose
  228. #    focus event, not one generated by the mouse moving out of the
  229. #    toplevel window.  Calls the FocusOut command for the widget
  230. #    who loses its focus.
  231. #
  232. proc ::tk::FocusGroup_Out {t w detail} {
  233.     variable FocusOut
  234.     variable ::tk::Priv
  235.  
  236.     if {$detail ne "NotifyNonlinear" && $detail ne "NotifyNonlinearVirtual"} {
  237.     # This is caused by mouse moving out of the window
  238.     return
  239.     }
  240.     if {![info exists Priv(focus,$t)]} {
  241.     return
  242.     }
  243.     if {![info exists FocusOut($t,$w)]} {
  244.     return
  245.     } else {
  246.     eval $FocusOut($t,$w)
  247.     set Priv(focus,$t) ""
  248.     }
  249. }
  250.  
  251. # ::tk::FDGetFileTypes --
  252. #
  253. #    Process the string given by the -filetypes option of the file
  254. #    dialogs. Similar to the C function TkGetFileFilters() on the Mac
  255. #    and Windows platform.
  256. #
  257. proc ::tk::FDGetFileTypes {string} {
  258.     foreach t $string {
  259.     if {[llength $t] < 2 || [llength $t] > 3} {
  260.         error "bad file type \"$t\", should be \"typeName {extension ?extensions ...?} ?{macType ?macTypes ...?}?\""
  261.     }
  262.     eval lappend [list fileTypes([lindex $t 0])] [lindex $t 1]
  263.     }
  264.  
  265.     set types {}
  266.     foreach t $string {
  267.     set label [lindex $t 0]
  268.     set exts {}
  269.  
  270.     if {[info exists hasDoneType($label)]} {
  271.         continue
  272.     }
  273.  
  274.     set name "$label \("
  275.     set sep ""
  276.     set doAppend 1
  277.     foreach ext $fileTypes($label) {
  278.         if {$ext eq ""} {
  279.         continue
  280.         }
  281.         regsub {^[.]} $ext "*." ext
  282.         if {![info exists hasGotExt($label,$ext)]} {
  283.         if {$doAppend} {
  284.             if {[string length $sep] && [string length $name]>40} {
  285.             set doAppend 0
  286.             append name $sep...
  287.             } else {
  288.             append name $sep$ext
  289.             }
  290.         }
  291.         lappend exts $ext
  292.         set hasGotExt($label,$ext) 1
  293.         }
  294.         set sep ","
  295.     }
  296.     append name "\)"
  297.     lappend types [list $name $exts]
  298.  
  299.     set hasDoneType($label) 1
  300.     }
  301.  
  302.     return $types
  303. }
  304.